home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / disk_425.arc / SIMQ1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-04-03  |  2.5 KB  |  139 lines
  1. program simq1;        { -> 67 }
  2. { pascal program to solve three simultaneous equations by Cramer's rule }
  3.  
  4. const    rmax    = 3;
  5.     cmax    = 3;
  6.  
  7. type    arys    = array[1..cmax] of real;
  8.     ary2s    = array[1..rmax,1..cmax] of real;
  9.  
  10. var    y,coef    : arys;
  11.     a    : ary2s;
  12.     n    : integer;
  13.     yesno    : char;
  14.     error    : boolean;
  15.  
  16. external procedure cls;
  17.  
  18. procedure get_data(var a: ary2s;
  19.            var y: arys;
  20.            var n: integer);
  21.  
  22. { get the values for n, and arrays a,y }
  23.  
  24. var    i,j    : integer;
  25.  
  26. begin    { procedure get_data }
  27.   writeln;
  28.   n:=rmax;
  29.   for i:=1 to n do
  30.     begin
  31.       writeln(' Equation',i:3);
  32.       for j:=1 to n do
  33.     begin
  34.       write(j:3,':');
  35.       read(a[i,j])
  36.     end;
  37.       write(',C:');
  38.       readln(y[i])
  39.     end;
  40.   writeln;
  41.   for i:=1 to n do
  42.     begin
  43.       for j:=1 to n do
  44.       write(a[i,j]:7:4,' ');
  45.       writeln(':',y[i]:7:4)
  46.     end;
  47.      writeln
  48. end;        { procedure get_data }
  49.  
  50. procedure write_data;
  51.     { print out the answeres }
  52.  
  53. var    i    : integer;
  54.  
  55. begin    { write_data }
  56.   for i:=1 to n do
  57.     write(coef[i]:9:5);
  58.   writeln
  59. end;        { write_data }
  60.  
  61.  
  62. procedure solve(a: ary2s;
  63.         y: arys;
  64.      var coef: arys;
  65.         n: integer;
  66.     var error: boolean);
  67.  
  68. var
  69.     b    : ary2s;
  70.     i,j    : integer;
  71.     det    : real;
  72.  
  73.  
  74.  
  75. function deter(a: ary2s): real;
  76. { pascal program to calculate the determinant of a 3-by-3matrix }
  77.  
  78. var
  79.     sum    : real;
  80.  
  81. begin    { function deter }
  82.   sum:=a[1,1]*(a[2,2]*a[3,3]-a[3,2]*a[2,3])
  83.     -a[1,2]*(a[2,1]*a[3,3]-a[3,1]*a[2,3])
  84.     +a[1,3]*(a[2,1]*a[3,2]-a[3,1]*a[2,2]);
  85.   deter:=sum
  86. end;    { function deter }
  87.  
  88.  
  89.  
  90. procedure setup(var b: ary2s;
  91.          var coef: arys;
  92.             j: integer);
  93.  
  94. var    i    : integer;
  95.  
  96. begin    { setup }
  97.   for i:=1 to n do
  98.     begin
  99.       b[i,j]:=y[i];
  100.       if j>1 then b[i,j-1]:=a[i,j-1]
  101.     end;
  102.   coef[j]:=deter(b)/det
  103. end;    { setup }
  104.  
  105. begin        { procedure solve }
  106.   error:=false;
  107.   for i:=1 to n do
  108.     for j:=1 to n do
  109.       b[i,j]:=a[i,j];
  110.   det:=deter(b);
  111.   if det=0.0 then
  112.     begin
  113.       error:=true;
  114.       writeln(chr(7),'ERROR: matrix is singular.')
  115.     end
  116.   else
  117.     begin
  118.       setup(b,coef,1);
  119.       setup(b,coef,2);
  120.       setup(b,coef,3);
  121.     end    { else }
  122. end;    {procedure solve }
  123.  
  124.  
  125. begin        { MAIN program }
  126.   cls;
  127.   writeln;
  128.   writeln('Simultaneous solution by Cramers rule');
  129.   repeat
  130.     get_data(a,y,n);
  131.     solve(a,y,coef,n,error);
  132.     if not error then write_data;
  133.     writeln;
  134.     write('More?');
  135.     readln(yesno);
  136.     cls
  137.   until(yesno<>'Y')and(yesno<>'y')
  138. end.
  139.